home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / shazam.exe / GDESKTOP.IMP < prev    next >
Encoding:
Text File  |  1992-09-01  |  16.3 KB  |  483 lines
  1.    {*******************************************************************
  2.  
  3.    GDESKTOP.IMP
  4.  
  5.    *******************************************************************}
  6.    {===================================================================
  7.  
  8.    HISTORY
  9.  
  10.    ===================================================================}
  11.    {-------------------------------------------------------------------
  12.    SAVE
  13.    -------------------------------------------------------------------}
  14. procedure SaveHistory ( VAR S : TStream ) ;
  15. var
  16.    Size                      : word ;
  17. begin
  18.    if S.Status <> stOk then EXIT ;
  19.    Size                      := HistoryUsed
  20.                                 - PtrRec ( HistoryBlock ).Ofs ;
  21.    S.Write ( Size , SizeOf ( Word ) ) ;
  22.    S.Write ( HistoryBlock^ , Size ) ;
  23. end ;
  24.    {-------------------------------------------------------------------
  25.    LOAD
  26.    -------------------------------------------------------------------}
  27. procedure LoadHistory ( VAR S : TStream ) ;
  28. var
  29.    Size                      : word ;
  30. begin
  31.    if S.Status <> stOk then EXIT ;
  32.    S.Read ( Size , SizeOf ( Word ) ) ;
  33.    S.Read ( HistoryBlock^ , Size ) ;
  34.    if S.Status = stOk then
  35.       HistoryUsed               := PtrRec ( HistoryBlock ).Ofs
  36.                                    + Size
  37.    else
  38.       ClearHistory ;
  39. end ;
  40.    {===================================================================
  41.  
  42.    PALETTE - saves all three (3) palettes.  Note that we do NOT want to
  43.    save the actual "AppPalette", since we would lose auto-detect.  This
  44.    could happen when using dual monitors, changing from color to B&W or
  45.    vice-versa, and (no doubt) there are other possibilities.
  46.  
  47.    To force a palette, use command-line switches and call hdColor,
  48.    hdBlackWhite or hdMonochrome AFTER application starts.
  49.  
  50.    ===================================================================}
  51.    {-------------------------------------------------------------------
  52.    SAVE
  53.    -------------------------------------------------------------------}
  54. procedure SavePalette ( VAR S : TStream ) ;
  55. var
  56.    SaveAppPalette            : integer ;
  57.    P                         : PString ;
  58. begin
  59.    if S.Status <> stOk then EXIT ;
  60.    SaveAppPalette            := AppPalette ;
  61.    for AppPalette := apColor to apMonochrome do
  62.    begin
  63.       P                      := NewStr ( Application^.GetPalette^ ) ;
  64.       S.WriteStr ( P ) ;
  65.       DisposeStr ( P ) ;
  66.    end ;
  67.    AppPalette                := SaveAppPalette ;
  68. end ;
  69.    {-------------------------------------------------------------------
  70.    LOAD
  71.    -------------------------------------------------------------------}
  72. procedure LoadPalette ( VAR S : TStream ) ;
  73. var
  74.    SaveAppPalette            : integer ;
  75.    P                         : PString ;
  76. begin
  77.    if S.Status <> stOk then EXIT ;
  78.    SaveAppPalette            := AppPalette;
  79.    for AppPalette := apColor to apMonochrome do
  80.    begin
  81.       P                      := S.ReadStr ;
  82.       Application^.GetPalette^ := TPalette ( P^ ) ;
  83.       DisposeStr ( P ) ;
  84.    end ;
  85.    AppPalette                := SaveAppPalette ;
  86.    if S.Status <> stOk then
  87.       hdResetColors ;
  88.    hdRefreshDisplay ;
  89. end ;
  90.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  91.  
  92.    DESKTOP - Must apply TEditor Load/Store patch!
  93.  
  94.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  95.    {===================================================================
  96.  
  97.    STORE
  98.  
  99.    ===================================================================}
  100. procedure DesktopWriteViews ( VAR S : TStream ) ;
  101.    {-------------------------------------------------------------------
  102.    IF VISIBLE
  103.    -------------------------------------------------------------------}
  104. procedure WriteView ( P : PView ) ; FAR ;
  105. begin
  106.    if P = Desktop^.Last then EXIT ;
  107.    if P^.GetState ( sfVisible ) then
  108.       S.Put ( P ) ;
  109. end ;
  110.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  111.    PROCESS
  112.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  113. begin
  114.    if S.Status <> stOk then EXIT ;
  115.    Desktop^.ForEach ( @WriteView ) ;
  116.    S.Put ( NIL ) ;
  117. end ;
  118.    {===================================================================
  119.  
  120.    LOAD - One at a time; "ValidView" calls "OutOfMemory" if LowMemory
  121.           is TRUE.
  122.  
  123.    NOTE:  Default "OutOfMemory" does nothing - should be overridden.
  124.  
  125.    ===================================================================}
  126. procedure DesktopReadViews ( VAR S : TStream ) ;
  127. var
  128.    P                         : PView ;
  129. begin
  130.    if S.Status <> stOk then EXIT ;
  131.    while TRUE do
  132.    begin
  133.       P                   := PView ( S.Get ) ;
  134.       Desktop^.InsertBefore ( Application^. ValidView ( P ) ,
  135.                               Desktop^.Last ) ;
  136.       if P = NIL then EXIT ;
  137.    end ;
  138. end ;
  139.    {===================================================================
  140.  
  141.    SAVE
  142.  
  143.    ===================================================================}
  144. procedure SaveDesktopTo ( FileName : PathStr ; Description : string ) ;
  145. var
  146.    Strm                      : PStream ;
  147. begin
  148.    if FileName = '' then EXIT ;
  149.    SaveEdUntitled ;                                        { save, or }
  150.    CloseEdUntitled ;                                   { dump empties }
  151.    SaveEdModified ;                                    { keep changes }
  152.    Strm                      := New ( PDosStream ,
  153.                                       Init ( FileName ,
  154.                                              stCreate ) ) ;
  155.    Description               := Description + #26 ;
  156.    Strm^.Write ( Description[1] , length ( Description ) ) ;
  157.    Strm^.Write ( VersionCode[0] , length ( VersionCode ) + 1 ) ;
  158.    SaveHistory ( Strm^ ) ;
  159.    SavePalette ( Strm^ ) ;
  160.    DesktopWriteViews ( Strm^ ) ;
  161.    if Strm^.Status <> stOk then
  162.    begin
  163.       FileErase ( FileName ) ;
  164.       MessageBox ( ^C'Could not create'#13
  165.                     + FileName ,
  166.                       NIL ,
  167.                       mfError + mfOkButton ) ;
  168.    end ;
  169.    Dispose ( Strm , Done ) ;
  170. end ;
  171.    {===================================================================
  172.  
  173.    LOAD
  174.  
  175.    ===================================================================}
  176. procedure LoadDesktopFrom ( FileName : PathStr ) ;
  177. var
  178.    Strm                      : PStream ;
  179.    VersionCodeTest           : string ;
  180.    Ch                        : char ;
  181. begin
  182.    if not FileExist ( FileName ) then EXIT ;
  183.    CloseAll ;
  184.    Strm                      := New ( PDosStream ,
  185.                                       Init ( FileName ,
  186.                                              stOpenRead ) ) ;
  187.    Ch                        := #0 ;
  188.    while ( Ch <> ^Z ) and ( Strm^.Status = stOK ) do
  189.       Strm^.Read ( Ch , 1 ) ;
  190.    Strm^.Read ( VersionCodeTest [0] , 1 ) ;
  191.    Strm^.Read ( VersionCodeTest [1] , length ( VersionCode ) ) ;
  192.    if VersionCode = VersionCodeTest then
  193.    begin
  194.       LoadHistory ( Strm^ ) ;
  195.       LoadPalette ( Strm^ ) ;
  196.       DesktopReadViews ( Strm^ ) ;
  197.    end
  198.    else
  199.    begin
  200.       Strm^.Seek ( 0 ) ;
  201.       Strm^.Truncate ;
  202.       Strm^.Reset ;
  203.       if Application <> NIL then
  204.          MessageBox ( ^C'DESKTOP version change to ' + VersionCode ,
  205.                       NIL ,
  206.                       mfWarning + mfOKButton ) ;
  207.    end ;
  208.    if Strm^.Status <> stOk then
  209.       MessageBox ( ^C'Error reading desktop file'#13
  210.                    + FileName ,
  211.                    NIL ,
  212.                    mfError + mfOkButton ) ;
  213.    Dispose ( Strm , Done ) ;
  214. end ;
  215.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  216.  
  217.    EVENT
  218.  
  219.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  220.    {===================================================================
  221.  
  222.    COMMAND - easy way to pass commands
  223.  
  224.    ===================================================================}
  225. procedure CommandAll ( Command : word ) ;
  226.    {-------------------------------------------------------------------
  227.    Send command
  228.    -------------------------------------------------------------------}
  229. procedure Action ( P : PView ) ; FAR ;
  230. begin
  231.    Message ( P , evCommand , Command , NIL ) ;
  232. end ;
  233.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  234.    PROCESS
  235.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  236. begin
  237.    Desktop^.ForEach ( @Action ) ;
  238. end ;
  239.    {===================================================================
  240.  
  241.    CLOSE - all valid windows
  242.  
  243.    ===================================================================}
  244. procedure CloseAll ;
  245. begin
  246.    CommandAll ( cmClose ) ;
  247. end ;
  248.    {===================================================================
  249.  
  250.    SHOW
  251.  
  252.    ===================================================================}
  253. procedure ShowAll ;
  254.    {-------------------------------------------------------------------
  255.    CALL METHOD
  256.    -------------------------------------------------------------------}
  257. procedure Action ( P : PView ) ; FAR ;
  258. begin
  259.    if P = PVIEW ( ClipWindow ) then EXIT ;
  260.    P^.Show ;
  261. end ;
  262.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  263.    PROCESS
  264.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  265. begin
  266.    DeskTop^.Lock ;
  267.    Desktop^.ForEach ( @Action ) ;
  268.    DeskTop^.Unlock ;
  269. end ;
  270.    {===================================================================
  271.  
  272.    HIDE
  273.  
  274.    ===================================================================}
  275. procedure HideAll ;
  276.    {-------------------------------------------------------------------
  277.    Any view
  278.    -------------------------------------------------------------------}
  279. procedure Action ( P : PView ) ; FAR ;
  280. begin
  281.    P^.Hide ;
  282. end ;
  283.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  284.    PROCESS
  285.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  286. begin
  287.    DeskTop^.Lock ;
  288.    Desktop^.ForEach ( @Action ) ;
  289.    DeskTop^.Unlock ;
  290.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  291.    Another way to do the same thing...
  292.    while Desktop^.Current <> NIL do
  293.       Desktop^.Current^.Hide;
  294.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  295. end ;
  296.    {===================================================================
  297.  
  298.    EVENT
  299.  
  300.    ===================================================================}
  301. procedure ForceEvent ( What , Command : word ) ;
  302. var
  303.    E                         : TEvent ;
  304. begin
  305.    E.What                    := What ;
  306.    E.Command                 := Command ;
  307.    Application^.PutEvent ( E ) ;
  308. end ;
  309.    {===================================================================
  310.  
  311.    ZOOMED WITHIN OWNER?
  312.  
  313.    ===================================================================}
  314. function IsZoomed ( P : PView ) : boolean ;
  315. begin
  316.    IsZoomed                  := FALSE ;
  317.    if ( P = NIL ) or ( P^.Owner = NIL ) then EXIT ;
  318.    if ( P^.Origin.X <> 0 ) or
  319.       ( P^.Origin.Y <> 0 ) or
  320.       ( P^.Size.X <> P^.Owner^.Size.X ) or
  321.       ( P^.Size.Y <> P^.Owner^.Size.Y ) then
  322.       EXIT ;
  323.    IsZoomed                  := TRUE ;
  324. end ;
  325.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  326.  
  327.    UTILITY
  328.  
  329.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  330. function Visible ( P : PView ) : boolean ;
  331. begin
  332.    Visible                   := P^.State and sfVisible <> 0 ;
  333. end ;
  334.  
  335. function Active ( P : PView ) : boolean ;
  336. begin
  337.    Active                    := P^.State and sfActive <> 0 ;
  338. end ;
  339.  
  340. function Tileable ( P : PView ) : boolean ;
  341. begin
  342.    Tileable                  := P^.Options and ofTileable <> 0 ;
  343. end ;
  344.  
  345. function Selectable ( P : PView ) : boolean ;
  346. begin
  347.    Selectable                := P^.Options and ofSelectable <> 0 ;
  348. end ;
  349.    {===================================================================
  350.  
  351.    CAN ZOOM?
  352.  
  353.    ===================================================================}
  354. function Zoomable ( P : PView ) : boolean ;
  355. begin
  356.    if Selectable ( P ) then
  357.       Zoomable               := PWINDOW ( P )^.Flags and wfZoom <> 0
  358.    else
  359.       ZoomAble               := FALSE ;
  360. end ;
  361.    {===================================================================
  362.  
  363.    ACTIVE - Active and Visible
  364.  
  365.    ===================================================================}
  366. function ExistActive : boolean ;
  367.    {-------------------------------------------------------------------
  368.    Test view
  369.    -------------------------------------------------------------------}
  370. function Test ( P : PView ) : boolean ; FAR ;
  371. begin
  372.    Test                      := Active ( P ) and Visible ( P ) ;
  373. end ;
  374.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  375.    PROCESS
  376.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  377. begin
  378.    ExistActive               := Desktop^.FirstThat ( @Test ) <> NIL ;
  379. end ;
  380.    {===================================================================
  381.  
  382.    SELECT - COUNT
  383.  
  384.    ===================================================================}
  385. function CountSelectable : byte ;
  386. var
  387.    B                         : byte ;
  388.    {-------------------------------------------------------------------
  389.    Selectable and Visible
  390.    -------------------------------------------------------------------}
  391. procedure Action ( P : PView ) ; FAR ;
  392. begin
  393.    if Selectable ( P ) and Visible ( P ) then
  394.       inc ( B ) ;
  395. end ;
  396.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  397.    PROCESS
  398.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  399. begin
  400.    B                         := 0 ;
  401.    Desktop^.ForEach ( @Action ) ;
  402.    CountSelectable           := B ;
  403. end ;
  404.    {===================================================================
  405.  
  406.    TILE - COUNT
  407.  
  408.    ===================================================================}
  409. function CountTileable : byte ;
  410. var
  411.    B                         : byte ;
  412.    {-------------------------------------------------------------------
  413.    Tileable and Visible
  414.    -------------------------------------------------------------------}
  415. procedure Action ( P : PView ) ; FAR ;
  416. begin
  417.    if Tileable ( P ) and Visible ( P ) then
  418.       inc ( B ) ;
  419. end ;
  420.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  421.    PROCESS
  422.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  423. begin
  424.    B                         := 0 ;
  425.    Desktop^.ForEach ( @Action ) ;
  426.    CountTileable             := B ;
  427. end ;
  428.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  429.  
  430.    PICK LIST
  431.  
  432.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  433.    {===================================================================
  434.  
  435.    Get list of titled windows from Desktop
  436.  
  437.    ===================================================================}
  438. procedure GetTitleList ( AList : PCollection ) ;
  439.    {-------------------------------------------------------------------
  440.    -------------------------------------------------------------------}
  441. procedure Action ( P : PView ) ; FAR ;
  442. begin
  443.    if not Selectable ( P ) then EXIT ;
  444.    with PWINDOW ( P ) ^ do
  445.       if GetTitle ( 255 ) <> '' then
  446.          AList^.Insert ( NewStr ( GetTitle ( 255 ) ) )
  447.       else
  448.          AList^.Insert ( NewStr ( '(blank title)' ) ) ;
  449. end ;
  450.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  451.    PROCESS
  452.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  453. begin
  454.    Desktop^.ForEach ( @Action ) ;
  455. end ;
  456.    {===================================================================
  457.  
  458.    SELECT - get window by its order number
  459.  
  460.    ===================================================================}
  461. procedure SelectNum ( AFocus : integer ) ;
  462. var
  463.    i                         : integer ;
  464.    {-------------------------------------------------------------------
  465.    -------------------------------------------------------------------}
  466. function Test ( P : PView ) : boolean ; FAR ;
  467. begin
  468.    Test                      := FALSE ;
  469.    if not Selectable ( P ) then EXIT ;
  470.    inc ( i ) ;
  471.    if i - 1 <> AFocus then EXIT ;
  472.    P^.Show ;
  473.    P^.Select ;
  474.    Test                      := TRUE ;
  475. end ;
  476.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  477.    PROCESS
  478.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  479. begin
  480.    i                         := 0 ;
  481.    Desktop^.FirstThat ( @Test ) ;
  482. end ;
  483.